home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / cmln0786.arc / GRAFTAL1.LTG next >
Text File  |  1986-03-31  |  7KB  |  217 lines
  1.  
  2. Graftals Listing 1
  3.  
  4. program graftal;
  5. {$I c:\turbo\graph.p } { required for circle command to draw leaves }
  6. { Program by Ken Birdwell and Steve Estvanik }                      
  7. type
  8.   bytearray  = array [0..10000] of byte;
  9.   codearray  = array [0..7,0..20] of byte;
  10.   realarray = array [0..10] of real;
  11. var
  12.     code    : codearray;
  13.     graftal : bytearray;
  14.     ang     : realarray;
  15.     graftal_len, gen, num_gen, num_ang, i, j : integer;
  16. procedure getcode(var num_var : integer;
  17.                   var code : codearray;
  18.                   var ang : realarray;
  19.                   var num_ang : integer );
  20.   var key : string[20];
  21.       d, g : integer;
  22.   begin
  23.     write('Enter number of generations: ');
  24.     readln(num_gen);
  25.     for d := 0 to 7 do
  26.        begin
  27.        write('Enter key for ',d :1, ':  ');
  28.        readln(key);
  29.        code[d,0] := length(key);
  30.        for g := 1 to code[d,0] do
  31.           case key[g] of
  32.             '0' : code[d,g] := 0;
  33.             '1' : code[d,g] := 1;
  34.             '[' : code[d,g] := 128;
  35.             ']' : code[d,g] := 64;
  36.           end;
  37.       end;
  38.       write('Enter number of angles: ');
  39.       readln(num_ang);
  40.       for g := 1 to num_ang do
  41.          begin
  42.          write ('enter angle (deg) ', g : 2, ': ');
  43.          readln(i);
  44.          ang[g-1] := i*3.1415/180;
  45.          end;
  46.   end;
  47. function findnext(p : integer;
  48.                    var orig : bytearray;
  49.                    var orig_len : integer ) : integer ;
  50. var
  51.     found : boolean;
  52.     depth : integer;
  53.     begin
  54.        depth := 0;
  55.        found := FALSE;è       while (p < orig_len) and not found
  56.           begin
  57.           p := p + 1;
  58.           if (depth = 0) and (orig[p] < 2 ) then
  59.              begin
  60.              findnext := orig[p];
  61.              found := TRUE;
  62.              end
  63.           else if (depth = 0 and orig[p] and 64) then
  64.              begin
  65.              findnext := 1;
  66.              found := TRUE;
  67.              end
  68.           else if (orig[p] and 128) <> 0 then
  69.              depth := depth + 1
  70.           else if (orig[p] and 64) <> 0 then
  71.              depth := depth - 1;
  72.           end;
  73.         if (not found) then
  74.           findnext := 1;
  75.     end;
  76. procedure add_new(b2, b1, b0 : integer;
  77.                   var dest : bytearray;
  78.                   var code : codearray;
  79.                   var dest_len : integer;
  80.                   num_ang : integer );
  81.     var d, i : integer;
  82.     begin
  83.         d := b2 * 4 + b1 * 2 + b0;
  84.         for i := 1 to code[d, 0] do
  85.            begin
  86.            dest_len := dest_len + 1;
  87.            case code[d,i] of
  88.               0..63 : dest[dest_len] := code[d,i];
  89.               64    : dest[dest_len] := 64;
  90.               128   : dest[dest_len] := 128 + random(num_ang);
  91.               end;
  92.         end;
  93.     end;
  94. procedure generation (var orig : bytearray;
  95.                       var orig_len : integer;
  96.                       var code : codearray );
  97.     var depth, dest_len,g,a : integer ;
  98.         b0,b1,b2            : byte ;
  99.         stack               : array [0..200] of integer;
  100.         dest                : bytearray;
  101.     begin
  102.        depth := 0;
  103.        dest_len := 0;
  104.        b2 := 1;
  105.        b1 := 1;
  106.        for g := 1 to orig_len do
  107.           begin
  108.           if (orig[g] < 2) then
  109.              beginè             b2 := b1;
  110.              b1 := orig[g];
  111.              b0 := findnext(g, orig, orig_len);
  112.              add_new(b2, b1, b0, dest, code, dest_len, num_ang) ;
  113.              end
  114.           else if (orig[g] and 128) <> 0 then
  115.              begin
  116.              dest_len := dest_len + 1;
  117.              dest[dest_len] := orig[g];
  118.              depth := depth + 1;
  119.              stack[depth] := b1;
  120.              end
  121.           else if (orig[g] and 64) <>0 then
  122.              begin
  123.              dest_len := dest_len + 1;
  124.              dest[dest_len] := orig[g];
  125.              b1 := stack[depth];
  126.              depth := depth - 1;
  127.              end;
  128.           end;
  129.        for a := 1 to dest_len do
  130.           orig[a] := dest[a];
  131.        orig_len := dest_len;
  132.     end;
  133. procedure print_generation(var graftal : bytearray;
  134.                            var graftal_len : integer);
  135.     var p : integer;
  136.     begin
  137.         gotoxy(1,1);
  138.         writeln('');
  139.         for p := 1 to graftal_len do
  140.             begin
  141.             if (graftal[p] < 2)          then write(graftal[p]:1);
  142.             if (graftal[p] and 128) <> 0 then write('[');
  143.             if (graftal[p] and 64)  <> 0 then write(']');
  144.             end;
  145.         writeln('');
  146.     end;
  147. procedure draw_generation (var graftal : bytearray;
  148.                            var graftal_len : integer;
  149.                            var ang : realarray;
  150.                            var gen : integer);
  151.     var a_ra, a_xp, a_yp       : array[0..50] of real;
  152.         ra, dx, dy, xp, yp, ll : real;
  153.         g, depth               : integer;
  154.     begin
  155.         graphcolormode;
  156.         xp := 140;
  157.         yp := 180;
  158.         ll := 5;
  159.         dx := 0;
  160.         dy := -ll;
  161.         gotoxy(1,1);
  162.         write('Gen ',gen);
  163.         for g := 1 to graftal_len doè            begin
  164.             if (graftal[g] < 2) then
  165.                begin
  166.                { drop shadow }
  167.                {draw (round(xp)-1, round(yp)-1,
  168.                       round(xp+dx)-1,round(yp+dy)-1,0);}
  169.                { plot 0 and 1 as green and yellow }
  170.                draw (round(xp), round(yp),
  171.                      round(xp+dx), round(yp+dy),graftal[g]*2+1);
  172.                xp := xp + dx;
  173.                yp := yp + dy;
  174.                end;
  175.             { start of branch}
  176.             if (graftal[g] and 128) <> 0 then
  177.                begin
  178.                depth := depth + 1;
  179.                a_ra[depth] := ra;
  180.                a_xp[depth] := xp;
  181.                a_yp[depth] := yp;
  182.                ra := ra + ang[graftal[g] and $7f];
  183.                dx := sin(ra)*ll;
  184.                dy := -cos(ra)*ll;
  185.                end;
  186.             { end of branch}
  187.             if (graftal[g] and 64) <> 0 then
  188.                begin
  189.                { include next line to show red leaves }
  190.                { circle (round(xp),round(yp),3,2); }
  191.                ra := a_ra[depth];
  192.                xp := a_xp[depth];
  193.                yp := a_yp[depth];
  194.                depth := depth - 1;
  195.                dx := sin(ra)*ll;
  196.                dy := -cos(ra)*ll;
  197.                end;
  198.             end;
  199.     end;
  200. begin
  201.     getcode(num_gen, code, ang, num_ang);
  202.     graftal_len := 1;
  203.     graftal[graftal_len] := 1;
  204.     for gen := 1 to num_gen do
  205.         begin
  206.         generation(graftal, graftal_len, code);
  207.         draw_generation(graftal, graftal_len, ang, gen);
  208.         {print_generation(graftal, graftal_len);}
  209.         end;
  210.    readln(i);
  211. end.
  212.  
  213.  
  214.  
  215.  
  216.  
  217. è